
 {$S+}
 { $I link0 }

     (******************************************************************)
     (*                                                                *)
     (*  Copyright (c) 1978 Regents of the University of California.   *)
     (*  Permission to copy or distribute this software or documen-    *)
     (*  tation in hard or soft copy granted only by written license   *)
     (*  obtained from the Institute for Information Systems.          *)
     (*                                                                *)
     (******************************************************************)

 {$U-,R+


         UCSD  PASCAL  SYSTEM
           PROGRAM  LINKER

         Written summer '78 by
         Roger T. Sumner, IIS

         Copyright (c) 1978, Regents of
         the University of California

     All hope abandon ye who enter here
                         -Dante

 }

 program systemlevel;

 const
     SYSPROG = 4;

 var
     syscom: ^integer;
     gfiles: array [0..5] of integer;
     userinfo: record
                 filler: array [0..4] of integer;
                 slowterm, stupid: boolean;
                 altmode: char;
                 gotsym, gotcode: boolean;
                 workvid, symvid, codevid: string[7];
                 worktid, symtid, codetid: string[15]
               end;
     filler: array [0..4] of integer;
     syvid, dkvid: string[7];
     junk1, junk2: integer;
     cmdstate: integer;

 {
 *  The linker is made up of three phases:
 *     Phase1 which open all input files, reads up seg tables
 *            from them and decides which segments are to be
 *            linked into the final code file.
 *     Phase2 reads the linker info for each segment that is
 *            going to be used, either to select sep procs from
 *            or copy with modifications into output code.
 *            The main symbol tree are built here, one for each
 *            code segment.
 *     Phase3 does the crunching of code segments into their
 *            final form by figuring out the procs that need to
 *            be linked in, resolves all references (PUBLREF,
 *            GLOBREF, etc), patches the code pointed to by their
 *            reflists, and writes the final code seg(s).
 }

 segment procedure linker(iii, jjj: integer);

 const
     MAXSEG = 15;        { max code seg # in code files }
     MAXSEG1 = 16;       { MAXSEG+1, useful for loop vars }
     MASTERSEG = 1;      { USERHOST segment number # }
     FIRSTSEG =  7;      { first linker assignable seg # }
     MAXFILE = 7;        { number of lib files we can use }
     MAXLC = MAXINT;     { max compiler assigned address }
     MAXIC = 14000;      { max number bytes of code per proc }
     MAXPROC = 160;      { max legal procedure number }
     MSDELTA = 12;       { mark stack size for pub/priv fixup }

 type

     { subranges }
     { --------- }

     segrange = 0..MAXSEG;       { seg table subscript type }
     segindex = 0..MAXSEG1;      { wish we had const expressions! }
     lcrange = 1..MAXLC;         { base offsets a la P-code }
     icrange = 0..MAXIC;         { legal length for proc/func code }
     procrange = 1..MAXPROC;     { legit procedure numbers }

     { miscellaneous }
     { ------------- }

     alpha = packed array [0..7] of char;
     diskblock = packed array [0..511] of 0..255;
     codefile = file;            { trick compiler to get ^file }
     filep = ^codefile;
     codep = ^diskblock;         { space management...non-PASCAL kludge }

     { link info structures }
     { ---- ---- ---------- }

     placep = ^placerec;         { position in source seg }
     placerec = record
                  srcbase, destbase: integer;
                  length: icrange
                end { placerec } ;

     refp = ^refnode;            { in-core version of ref lists }
     refnode = record
                 next: refp;
                 refs: array [0..7] of integer;
               end { refnode } ;

     litypes = (EOFMARK,         { end-of-link-info marker }
                    { ext ref types, designates      }
                    { fields to be updated by linker }
                UNITREF,         { refs to invisibly used units (archaic?) }
                GLOBREF,         { refs to external global addrs }
                PUBLREF,         { refs to BASE lev vars in host }
                PRIVREF,         { refs to BASE vars, allocated by linker }
                CONSTREF,        { refs to host BASE lev constant }
                    { defining types, gives      }
                    {  linker values to fix refs }
                GLOBDEF,         { global addr location }
                PUBLDEF,         { BASE var location }
                CONSTDEF,        { BASE const definition }
                    { proc/func info, assem }
                    { to PASCAL and PASCAL  }
                    { to PASCAL interface   }
                EXTPROC,         { EXTERNAL proc to be linked into PASCAL }
                EXTFUNC,         {    "     func "  "    "    "      "    }
                SEPPROC,         { Separate proc definition record }
                SEPFUNC,         {   "      func     "        "    }
                SEPPREF,         { PASCAL ref to a sep proc }
                SEPFREF);        {   "    ref to a sep func }

     liset = set of litypes;
     opformat = (WORD, BYTE, BIG);       { instruction operand field formats }

     lientry = record    { format of link info records }
                 name: alpha;
                 case litype: litypes of
                   SEPPREF,
                   SEPFREF,
                   UNITREF,
                   GLOBREF,
                   PUBLREF,
                   PRIVREF,
                   CONSTREF:
                         (format: opformat;      { how to deal with the refs }
                          nrefs: integer;        { words following with refs }
                          nwords: lcrange;       { size of private or nparams }
                          reflist: refp);        { list of refs after read in }
                   EXTPROC,
                   EXTFUNC,
                   SEPPROC,
                   SEPFUNC:
                         (srcproc: procrange;    { the procnum in source seg }
                          nparams: integer;      { words passed/expected }
                          place: placep);        { position in source/dest seg }
                   GLOBDEF:
                         (homeproc: procrange;   { which proc it occurs in }
                          icoffset: icrange);    { its byte offset in pcode }
                   PUBLDEF:
                         (baseoffset: lcrange);  { compiler assign word offset }
                   CONSTDEF:
                         (constval: integer);    { users defined value }
                   EOFMARK:
                         (nextlc: lcrange)       { private var alloc info }
                 end { lientry } ;

     { symbol table items }
     { ------ ----- ----- }

     symp = ^symbol;
     symbol = record
                llink, rlink,            { binary subtrees for diff names }
                slink: symp;             { same name, diff litypes }
                entry: lientry           { actual id information }
              end { symbol } ;

     { segment information }
     { ------- ----------- }

     segkinds =(LINKED,          { no work needed, executable as is }
                HOSTSEG,         { PASCAL host program outer block  }
                SEGPROC,         { PASCAL segment procedure, not host }
                UNITSEG,         { library unit occurance/reference }
                SEPRTSEG);       { library separate proc/func TLA segment }

     finfop = ^fileinforec;      { forward type dec }

     segp = ^segrec;             { this structure provides access to all }
     segrec = record             { info for segs to be linked to/from    }
                srcfile: finfop;         { source file of segment }
                srcseg: segrange;        { source file seg # }
                symtab: symp;            { symbol table tree }
                case segkind: segkinds of
                  SEPRTSEG:
                         (next: segp)    { used for library sep seg list }
              end { segrec } ;

     { host/lib file access info }
     { ---- --- ---- ------ ---- }

     I5segtbl = record   { first full block of all code files }
                  diskinfo: array [segrange] of
                              record
                                codeleng, codeaddr: integer
                              end { diskinfo } ;
                  segname: array [segrange] of alpha;
                  segkind: array [segrange] of segkinds;
                  filler: array [0..143] of integer
                end { I5segtbl } ;

     filekind = (USERHOST, USERLIB, SYSTEMLIB);

     fileinforec = record
                     next: finfop;       { link to next file thats open }
                     code: filep;        { pointer to PASCAL file...sneaky! }
                     fkind: filekind;    { used to validate the segkinds }
                     segtbl: I5segtbl    { disk seg table w/ source info }
                   end { fileinforec } ;


 var
     hostfile,           { host file info ptr, its next = libfiles }
     libfiles: finfop;   { list of lib files, user and system }

     seplist: segp;      { list of sep segs to search through }
     reflitypes: liset;  { those litypes with ref lists }

     talkative,
     useworkfile: boolean;

     errcount: integer;
     heapbase: ^integer;

     hostsp: segp;                       { ptr to host prog outer block }
     nextbaselc: lcrange;                { next base offset for private alloc }
     seginfo: array [segrange] of segp;  { seg is available if NIL }
     nextseg: segindex;                  { next slot in seginfo available }

     mapname: string[40];

     f0, f1, f2, f3,
     f4, f5, f6, f7,                     { input files with lurking pntrs }
     code: codefile;                     { output code file, *system.wrk.code }


 {
 *  Print an error message and bump
 *  the error counter.
 }

 procedure error(msg: string);
   var ch: char;
 begin
   writeln(msg);
   repeat
     write('Type <sp>(continue), <esc>(terminate)');
     read(keyboard, ch);
     if ch = userinfo.altmode then
       exit(linker)
   until ch = ' ';
   errcount := errcount+1
 end { error } ;

 {
 *  Routines to access object code segments.  There
 *  is subtle business involving byte flipping with
 *  the 16-bit operations.  This needs more research
 *  when the time comes.
 }
 {$R-}

 function fetchbyte(cp: codep; offset: integer): integer;
 begin
   fetchbyte := cp^[offset]
 end { fetchbyte } ;

 function fetchword(cp: codep; offset: integer): integer;
   var i: integer;
 begin
   moveleft(cp^[offset], i, 2);
   { byte swap i }
   fetchword := i
 end { fetchword } ;

 procedure storebyte(val: integer; cp: codep; offset: integer);
 begin
   cp^[offset] := val
 end { storebyte } ;

 procedure storeword(val: integer; cp: codep; offset: integer);
 begin
   { byte swap val }
   moveleft(val, cp^[offset], 2)
 end { storeword } ;

 {$R+}

 {
 *  Enter newsym in symtab tree.  The tree is binary for
 *  different names and entries with the same name are entered
 *  onto sideways links (slink).  No check is made for dup
 *  entry types, caller must do that.  Nodes on slink will
 *  always have NIL rlink and llink.
 }

 procedure entersym(newsym: symp; var symtab: symp);
   var syp, lastsyp: symp;
       useleft: boolean;
 begin
   newsym^.llink := NIL;
   newsym^.rlink := NIL;
   newsym^.slink := NIL;
   if symtab = NIL then
     symtab := newsym
   else
     begin { search symtab and add newsym }
       syp := symtab;
       repeat
         lastsyp := syp;
         if syp^.entry.name > newsym^.entry.name then
           begin syp := syp^.llink; useleft := TRUE end
         else
           if syp^.entry.name < newsym^.entry.name then
             begin syp := syp^.rlink; useleft := FALSE end
           else { equal }
             begin { add into sideways list }
               newsym^.slink := syp^.slink;
               syp^.slink := newsym;
               lastsyp := NIL;     { already added flag }
               syp := NIL          { stop repeat loop }
             end
       until syp = NIL;
       if lastsyp <> NIL then
         begin { add to bottom of tree }
           if useleft then
             lastsyp^.llink := newsym
           else
             lastsyp^.rlink := newsym
         end
     end { symtab <> NIL }
 end { entersym } ;

 {
 *  Look up name in symtab tree and return pointer
 *  to it.  Oktype restricts what litype is
 *  acceptable.  NIL is returned if name not found.
 }

 function symsrch(var name: alpha; oktype: litypes; symtab: symp): symp;
   var syp: symp;
 begin
   symsrch := NIL;
   syp := symtab;
   while syp <> NIL do
     if syp^.entry.name > name then
       syp := syp^.llink
     else
       if syp^.entry.name < name then
         syp := syp^.rlink
       else { equal name }
         if syp^.entry.litype <> oktype then
           syp := syp^.slink
         else { found! }
           begin symsrch := syp; syp := NIL end
 end { symsrch } ;

 {
 *  Search for the occurance of the unit segment
 *  given by name in the list of files in fp.
 *  Return the file and segment number in seg.
 *  NIL is returned for non-existant units and
 *  an error is given.
 }

 function unitsrch(fp: finfop; var name: alpha; var seg: segrange): finfop;
   label 1;
   var s: segindex;
 begin seg := 0;
   while fp <> NIL do
     begin
       with fp^.segtbl do
         for s := 0 to MAXSEG do
           if segname[s] = name then
             if segkind[s] = UNITSEG then
               goto 1;
       fp := fp^.next
     end;
   write('Unit ', name);
   error(' not found');
   s := 0;
 1:
   seg := s;
   unitsrch := fp
 end { unitsrch } ;

 {
 *  Alphabetic returns TRUE if name contains all legal
 *  characters for PASCAL identifiers.  Used to validate
 *  segnames and link info entries.
 }

 function alphabetic(var name: alpha): boolean;
   label 1;
   var i: integer;
 begin
   alphabetic := FALSE;
   for i := 0 to 7 do
     if not (name[i] in ['A'..'Z', '0'..'9', ' ', '_']) then
       goto 1;
   alphabetic := TRUE;
 1:
 end { alphabetic } ;

 {
 *  Getcodep is a sneaky routine to point codep's anywhere
 *  in memory.  It violates Robot's Rules of Order, but is
 *  very useful for dealing with the variable size segments
 }

 function getcodep(memaddr: integer): codep;
   var r: record
            case boolean of
              TRUE:  (i: integer);
              FALSE: (p: codep)
            end;
 begin
   r.i := memaddr;
   getcodep := r.p
 end { getcodep } ;

 { $I link1 }

     (******************************************************************)
     (*                                                                *)
     (*  Copyright (c) 1978 Regents of the University of California.   *)
     (*  Permission to copy or distribute this software or documen-    *)
     (*  tation in hard or soft copy granted only by written license   *)
     (*  obtained from the Institute for Information Systems.          *)
     (*                                                                *)
     (******************************************************************)

 {
 *  Phase 1 opens host and library files and
 *  reads in seg tables.  All fields are verified
 *  and the hostfile/libfiles file list is built.
 *  The prototype final seg table is set up in
 *  seginfo[*] from the host file and the sep seg
 *  list is set up for searching in later phases.
 }

 procedure phase1;

     {
     *  Build file list opens input code files and reads segtbls.
     *  The var hostfile is set up as head of linked list of file
     *  info recs.  The order of these files determines how id's
     *  will be searched for.  Note that libfiles points at the
     *  list just past the host file front entry.
     }

     procedure buildfilelist;
       label 1;
       var f: 0..MAXFILE;
           i: integer;
           p, q: finfop;
           fname: string[40];

         {
         *  Setupfile opens file and enters new finfo rec in
         *  hostfile list.  Segtbl is read in and validated.
         }

         procedure setupfile(num: integer; kind: filekind; title: string);
           var errs: integer;
               s: segindex;
               cp: filep;
               fp: finfop;
               alllinked: boolean;
               goodkinds: set of segkinds;

             {
             *  Getfilep returns a pointer to a file using unspeakable
             *  methods, but the ends justify the means.
             }

             function getfilep(var f: codefile): filep;
               var a: array [0..0] of filep;
             begin
               {$R-}
               getfilep := a[-1];
               {$R+}
             end { getfilep } ;

         begin { setupfile }
           case num of
             0:  cp := getfilep(f0);
             1:  cp := getfilep(f1);
             2:  cp := getfilep(f2);
             3:  cp := getfilep(f3);
             4:  cp := getfilep(f4);
             5:  cp := getfilep(f5);
             6:  cp := getfilep(f6);
             7:  cp := getfilep(f7)
           end { cases } ;
           reset(cp^, title);
           if IORESULT <> 0 then
             if title <> 'in workspace' then
               begin
                 insert('.CODE', title, length(title)+1);
                 reset(cp^, title)
               end;
           if IORESULT <> 0 then
             begin
               insert('No file ', title, 1);
               error(title);
               if kind <> USERHOST then
                 errcount := errcount-1
             end
           else
             begin { file open ok }
               if talkative then
                 writeln('Opening ', title);
               new(fp);
               fp^.next := hostfile;
               fp^.code := cp;
               fp^.fkind := kind;
               if blockread(cp^, fp^.segtbl, 1, 0) <> 1 then
                 error('segtbl read err')
               else
                 begin { now check segtbl values }
                   s := 0; alllinked := TRUE;
                   errs := errcount;
                   if kind = USERHOST then
                     goodkinds := [LINKED,SEGPROC,SEPRTSEG,HOSTSEG,UNITSEG]
                   else
                     goodkinds := [LINKED,UNITSEG,SEPRTSEG];
                   with fp^.segtbl do
                     repeat
                       alllinked := alllinked and (segkind[s] = LINKED);
                       if (diskinfo[s].codeleng = 0)
                       and (segkind[s] <> LINKED) then
                         if (kind <> USERHOST)
                         or (segkind[s] <> UNITSEG) then
                           error('funny code seg');
                       if (diskinfo[s].codeleng < 0)
                       or (diskinfo[s].codeaddr < 0)
                       or (diskinfo[s].codeaddr > 300) then
                         error('bad diskinfo');
                       if not (segkind[s] in goodkinds) then
                         error('bad seg kind');
                       if not alphabetic(segname[s]) then
                         error('bad seg name');
                       if errcount > errs then
                         s := MAXSEG;
                       s := s+1
                     until s > MAXSEG;
                   if alllinked and (kind = USERHOST) then
                     begin
                       write('All segs linked');
                       exit(linker)
                     end;
                   if errcount = errs then
                     hostfile := fp            { ok file...link in }
                 end
             end
         end { setupfile } ;

     begin { buildfilelist }
       if talkative then
         begin
           for i := 1 to 7 do
             writeln;
           writeln('Linker [I.5]')
         end;
       useworkfile := cmdstate <> SYSPROG;
       with userinfo do
         if useworkfile then
           begin
             if gotcode then
               fname := concat(codevid, ':', codetid)
             else
               fname := 'in workspace';
             setupfile(0, USERHOST, fname);
             setupfile(1, SYSTEMLIB, '*SYSTEM.LIBRARY')
           end
         else
           begin
             write('Host file? ');
             readln(fname);
             if fname = '' then
               if gotcode then
                 fname := concat(codevid, ':', codetid)
               else
                 fname := 'in workspace';
             setupfile(0, USERHOST, fname);
             if errcount > 0 then
               exit(linker); { no host! }
             for f := 1 to MAXFILE do
               begin
                 write('Lib file? ');
                 readln(fname);
                 if fname = '' then
                   goto 1;
                 if fname = '*' then
                   setupfile(f, SYSTEMLIB, '*SYSTEM.LIBRARY')
                 else
                   setupfile(f, USERLIB, fname)
               end;
         1:
             write('Map name? ');
             readln(mapname);
             if mapname <> '' then
               if mapname[length(mapname)] = '.' then
                 delete(mapname, length(mapname), 1)
               else
                 insert('.TEXT', mapname, length(mapname)+1)
           end;

       { now reverse list so host is }
       { first and syslib is last    }

       p := hostfile; hostfile := NIL;
       repeat
         q := p^.next;
         p^.next := hostfile;
         hostfile := p;
         p := q
       until p = NIL;
       libfiles := hostfile^.next;
     end { buildfilelist } ;

     {
     *  Buildseginfo initializes the seginfo table from
     *  the host prototype seg table.  All legal states
     *  are checked, and imported units found.  This
     *  leaves a list of all segs to finally appear in
     *  the output code file.
     }

     procedure buildseginfo;
       label 1;
       var s: segindex;
           errs: integer;
           sp: segp;
     begin
       with hostfile^.segtbl do
         for s := 0 to MAXSEG do
           if (segkind[s] = LINKED)
           and (diskinfo[s].codeleng = 0) then
             seginfo[s] := NIL   { not in use }
           else
             begin { do something with seg }
               errs := errcount;
               new(sp);
               sp^.srcfile := hostfile;
               sp^.srcseg := s;
               sp^.symtab := NIL;
               sp^.segkind := segkind[s];
               case sp^.segkind of
                 SEGPROC,
                 LINKED:    ;  { nothing to check! }

                 HOSTSEG:   if s <> MASTERSEG then
                              error('bad host seg')
                            else
                              if hostsp <> NIL then
                                error('dup host seg')
                              else
                                hostsp := sp;

                 SEPRTSEG:  if s = MASTERSEG then
                              sp^.next := NIL
                            else
                              begin { put into seplist }
                                sp^.next := seplist;
                                seplist := sp;
                                sp := NIL
                              end;

                 UNITSEG:   if diskinfo[s].codeleng = 0 then
                              sp^.srcfile := unitsrch(libfiles,
                                                     segname[s],
                                                     sp^.srcseg)
               end { cases } ;
               if errs = errcount then
                 seginfo[s] := sp
               else
                 seginfo[s] := NIL
             end;

       { now find first assignable seg }

       for s := FIRSTSEG to MAXSEG do
         if seginfo[s] = NIL then
           goto 1;
       s := MAXSEG1;
     1:
       nextseg := s;
       if seginfo[MASTERSEG] = NIL then
         error('wierd host')
     end { buildseginfo } ;

     {
     *  Buildseplist searches through libraries and adds onto
     *  a global list of sep segs that are to be searched
     *  for procs and globals.  They are initially build in
     *  the reverse order, then reversed again so searches
     *  will go in the order the files were specified.
     }

     procedure buildseplist;
       var sp, p, q: segp;
           fp: finfop;
           s: segindex;
     begin
       fp := libfiles;
       while fp <> NIL do
         begin
           for s := 0 to MAXSEG do
             if fp^.segtbl.segkind[s] = SEPRTSEG then
               begin
                 new(sp);
                 sp^.next := seplist;
                 sp^.srcfile := fp;
                 sp^.srcseg := s;
                 sp^.symtab := NIL;
                 sp^.segkind := SEPRTSEG;
                 sp^.next := seplist;
                 seplist := sp
               end;
           fp := fp^.next
         end;

       { now reverse the list to maintain original order }

       p := seplist; seplist := NIL;
       while p <> NIL do
         begin
           q := p^.next;
           p^.next := seplist;
           seplist := p;
           p := q
         end
     end { buildseplist } ;

 begin { phase1 }

   { initialize globals }

   hostfile := NIL;
   libfiles := NIL;
   hostsp := NIL;
   seplist := NIL;
   reflitypes := [UNITREF, GLOBREF, PUBLREF,
                  PRIVREF, CONSTREF,
                  SEPPREF, SEPFREF];
   errcount := 0;
   nextbaselc := 3;
   mapname := '';
   talkative := not userinfo.slowterm;
   mark(heapbase);
   unitwrite(3, heapbase^, 35);

   { build list of input files }

   buildfilelist;
   if errcount > 0 then
     exit(linker);

   { init basic seg info table }

   buildseginfo;
   if errcount > 0 then
     exit(linker);

   { finally build sep seg list }
			
   buildseplist;
   if errcount > 0 then
     exit(linker)
 end { phase1 } ;

 { $I link2 }

     (******************************************************************)
     (*                                                                *)
     (*  Copyright (c) 1978 Regents of the University of California.   *)
     (*  Permission to copy or distribute this software or documen-    *)
     (*  tation in hard or soft copy granted only by written license   *)
     (*  obtained from the Institute for Information Systems.          *)
     (*                                                                *)
     (******************************************************************)

 {
 *  Phase2 reads in all linker info associated with
 *  the segs in seginfo and sep seg list.  Again all
 *  fields are checked carefully.  As a help to phase3,
 *  ref lists are collected and place records for sep
 *  proc/func are computed.  Some small optimization is
 *  done to eliminate the sep seg list if it is not
 *  going to be needed, saving a few disk IO's.
 }

 procedure phase2;
   var s: segindex;
       sp: segp;
       dumpseps: boolean;

     {
     *  Readlinkinfo reads in the link info for segment sp
     *  and builds its symtab.  Some simple disk io routines
     *  do unblocking, and all fields are again verified.
     *  The only legal litypes are in oktypes. Assume that
     *  sp <> NIL
     }

     procedure readlinkinfo(sp: segp; oktypes: liset);
       var rp, rq: refp;
           syp: symp;
           errs, nrecs, nextblk, recsleft: integer;
           entry, temp: lientry;
           buf: array [0..31] of
                  array [0..7] of integer;

         {
         *  Getentry reads an 8 word record from disk buf
         *  sequentially.  No validity checking is done here,
         *  only disk read errors.
         }

         procedure getentry(var entry: lientry);
           var err: boolean;
         begin
           err := FALSE;
           if recsleft = 0 then
             begin
               recsleft := 32;
               err := blockread(sp^.srcfile^.code^, buf, 1, nextblk) <> 1;
               if err then
                 error('li read err')
               else
                 nextblk := nextblk+1
             end;
           moveleft(buf[32-recsleft], entry, 16);
           if err then
             entry.litype := EOFMARK;
           recsleft := recsleft-1
         end { getentry } ;

         {
         *  Addunit is called to find or allocate a library unit
         *  that is found in link info as an external ref.  This
         *  occurs in lib units which use other units.  If
         *  the unit can't be found or no room, error is called.
         }

         procedure addunit(var name: alpha);
           var fp: finfop; seg: integer;
         begin
           fp := unitsrch(hostfile, name, seg);
           if fp <> NIL then
             if fp <> hostfile then
               if fp^.segtbl.diskinfo[seg].codeleng <> 0 then
                 if nextseg = MAXSEG1 then
                   error('no room in seginfo')
                 else
                   begin { allocate new seginfo el }
                     new(seginfo[nextseg]);
                     with seginfo[nextseg]^ do
                       begin
                         srcfile := fp;
                         srcseg := seg;
                         segkind := UNITSEG;
                         symtab := NIL
                       end;
                     nextseg := nextseg+1
                   end
         end { addunit } ;

         {
         *  Validate verifies lientry format.
         *  If the entry is SEPPROC or FUNC
         *  then a place rec is allocated for buildplace.  If
         *  a UNITREF is found, it searched for and possibly
         *  allocated.  If the unit must be added to seginfo,
         *  it is placed after current position so it will have
         *  its link info read as well.
         }

         procedure validate(var entry: lientry);
         begin
           with entry do
             if not alphabetic(name) then
               error('non-alpha name')
             else
               case litype of
                 SEPPREF,
                 SEPFREF,
                 UNITREF,
                 GLOBREF,
                 PUBLREF,
                 PRIVREF,
                 CONSTREF:  begin
                              reflist := NIL;
                              if (nrefs < 0)
                              or (nrefs > 500) then
                                error('too many refs');
                              if not (format in [WORD, BYTE, BIG]) then
                                error('bad format');
                              if litype = PRIVREF then
                                if (nwords <= 0)
                                or (nwords > MAXLC) then
                                  error('bad private');
                              if (litype = UNITREF) and (nrefs > 0) then
                                addunit(name)
                            end;
                 GLOBDEF:   if (homeproc <= 0)
                            or (homeproc > MAXPROC)
                            or (icoffset < 0)
                            or (icoffset > MAXIC) then
                              error('bad globdef');
                 PUBLDEF:   if (baseoffset <= 0)
                            or (baseoffset > MAXLC) then
                              error('bad publicdef');
                 EXTPROC,
                 EXTFUNC,
                 SEPPROC,
                 SEPFUNC:   begin
                              if litype in [SEPPROC,SEPFUNC] then
                                new(place) { for use in buildplaces }
                              else
                                place := NIL;
                              if (srcproc <= 0)
                              or (srcproc > MAXPROC)
                              or (nparams < 0)
                              or (nparams > 100) then
                                error('bad proc/func')
                            end
               end { case litype }
         end { validate } ;

     begin { readlinkinfo }
       recsleft := 0;      { 8 wd recs left in buf }
       with sp^.srcfile^.segtbl, diskinfo[sp^.srcseg] do
         begin { seek to linkinfo }
           nextblk := codeaddr + (codeleng+511) div 512;
           if talkative then
             writeln('Reading ', segname[sp^.srcseg])
         end;
       repeat
         getentry(entry);
         errs := errcount;
         if entry.litype <> EOFMARK then
           if entry.litype in oktypes then
             validate(entry)
           else
             begin
               error('bad litype');
               entry.litype := EOFMARK
             end;
         if dumpseps then
           if entry.litype in [SEPPREF, SEPFREF,
                               EXTPROC, EXTFUNC,
                               GLOBREF] then
             dumpseps := FALSE;  { we need them! }
         if entry.litype in reflitypes then
           begin { read ref list }
             nrecs := (entry.nrefs+7) div 8;
             while nrecs > 0 do
               begin { read ref rec }
                 getentry(temp);
                 new(rp);
                 moveleft(temp, rp^.refs, 16);
                 rp^.next := entry.reflist;
                 entry.reflist := rp;
                 nrecs := nrecs-1
               end;
             { reverse ref list }
             rp := entry.reflist;
             entry.reflist := NIL;
             while rp <> NIL do
               begin
                 rq := rp^.next;
                 rp^.next := entry.reflist;
                 entry.reflist := rp;
                 rp := rq
               end
           end;
         if entry.litype = EOFMARK then
           if sp^.segkind = HOSTSEG then
             if (entry.nextlc > 0)
             and (entry.nextlc <= MAXLC) then
               nextbaselc := entry.nextlc
             else
               error('bad host LC')
           else
         else
           if errs = errcount then
             begin { ok...add to symtab }
               new(syp);
               syp^.entry := entry;
               entersym(syp, sp^.symtab)
             end
       until entry.litype = EOFMARK
     end { readlinkinfo } ;

     {
     *  Buildplaces reads code of sep segs from disk to generate
     *  the placerec entries for use during phase3.  The seg is
     *  read into the heap and the grossness begins. Assume that
     *  sp <> NIL
     }

     procedure buildplaces(sp: segp);
       var cp: codep; heap: ^integer;
           nbytes, nblocks, nprocs, n: integer;

         {
         *  procsrch recursivly searches symtab of sp to find
         *  sepproc and sepfunc entries and build the actual
         *  place record for the link info entry by indexing
         *  thru proc dict to jtab and using entric field.
         }

         procedure procsrch(symtab: symp);
           var i, j: integer;
         begin
           if symtab <> NIL then
             begin
               procsrch(symtab^.llink);
               procsrch(symtab^.rlink);
               procsrch(symtab^.slink);
               with symtab^.entry do
                 if litype in [SEPPROC, SEPFUNC] then
                   if (srcproc <= 0) or (srcproc > nprocs) then
                     error('bad proc #')
                   else { find byte place in code }
                     begin
                       i := nbytes-2-2*srcproc;      { point i at proc dict }
                       i := i-fetchword(cp, i);      { point i at jtab }
                       if (fetchbyte(cp, i) <> srcproc)
                       and (fetchbyte(cp, i) <> 0) then
                         error('disagreeing p #')
                       else
                         begin
                           j := fetchword(cp, i-2)+4;
                           place^.srcbase := i+2-j;
                           if (place^.srcbase < 0)
                           or (j <= 0) or (j > MAXIC) then
                             error('proc place err')
                           else
                             place^.length := j
                         end
                     end
             end
         end { procsrch } ;

     begin { buildplaces }
       nbytes := sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeleng;
       nblocks := (nbytes+511) div 512;
       if memavail-400 < nblocks*256 then
         error('sep seg 2 big')
       else
         begin { alloc space in heap }
           mark(heap);
           n := nblocks;
           repeat
             new(cp);
             n := n-1
           until n <= 0;
           if blockread(sp^.srcfile^.code^, heap^, nblocks,
                sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeaddr) <> nblocks then
             error('sep seg read err')
           else
             begin
               cp := getcodep(ord(heap));
               nprocs := fetchbyte(cp, nbytes-1);
               if (nprocs < 0) or (nprocs > MAXPROC) then
                 error('bad proc dict')
               else
                 procsrch(sp^.symtab)
             end;
           release(heap)
         end
     end { buildplaces } ;

 begin { phase2 }

   mark(heapbase);
   unitwrite(3, heapbase^, 35);

   { read link info for host segs }

   dumpseps := TRUE;     { assume we don't need sep segs }
   for s := 0 to MAXSEG do
     if seginfo[s] <> NIL then
       case seginfo[s]^.segkind of
         LINKED:    ; { nothin }
         UNITSEG:   readlinkinfo(seginfo[s], [PUBLREF, PRIVREF, UNITREF,
                                              CONSTDEF,EXTPROC, EXTFUNC]);
         SEPRTSEG:  readlinkinfo(seginfo[s], [GLOBREF, GLOBDEF,
                                              CONSTDEF,SEPPROC, SEPFUNC]);
         HOSTSEG:   readlinkinfo(seginfo[s], [PUBLDEF, CONSTDEF,
                                              EXTPROC, EXTFUNC]);
         SEGPROC:   readlinkinfo(seginfo[s], [EXTPROC, EXTFUNC])
       end { cases } ;

   { now do sep list elements }

   if dumpseps then
     seplist := NIL;
   sp := seplist;
   while sp <> NIL do
     begin
       readlinkinfo(sp, reflitypes+[CONSTDEF, GLOBDEF, SEPPROC, SEPFUNC]);
       sp := sp^.next
     end;

   { build proc place entries for sep segs }

   if seginfo[MASTERSEG]^.segkind = SEPRTSEG then
     buildplaces(seginfo[MASTERSEG]);

   sp := seplist;
   while sp <> NIL do
     begin
       buildplaces(sp);
       sp := sp^.next
     end;
   if errcount > 0 then
     exit(linker)
 end { phase2 } ;

 { $I link3a }

     (******************************************************************)
     (*                                                                *)
     (*  Copyright (c) 1978 Regents of the University of California.   *)
     (*  Permission to copy or distribute this software or documen-    *)
     (*  tation in hard or soft copy granted only by written license   *)
     (*  obtained from the Institute for Information Systems.          *)
     (*                                                                *)
     (******************************************************************)

 {
 *  Phase3 of the linker does all the real work of code
 *  massaging.  For each segment in seginfo to be placed
 *  into the output code file, all referenced procedures
 *  and functions are found, globals and other refs are
 *  resolved, and finally the final code segment is built.
 *  In the case of a SEPRTSEG host (eg an interpreter), then
 *  all the procs in it are put in the unresolved list and
 *  the host seg is made to appear as just another sep seg.
 *  This drags along all the original procedures and maintains
 *  their original ordering for possible ASECT integrity.
 }

 procedure phase3;
   type
       workp = ^workrec;         { all seg work is driven by these lists }
       workrec = record
                   next: workp;          { list link }
                   refsym,               { symtab entry of unresolved name }
                   defsym: symp;         {   "      "   "  resolving entry }
                   refseg,               { seg refls point into, refrange only }
                   defseg: segp;         { seg where defsym was found }
                   case litypes of       { same as litype in refsym^.entry }
                     SEPPREF,
                     SEPFREF,
                     GLOBREF:
                         (defproc: workp);       { work item of homeproc }
                     UNITREF:
                         (defsegnum: segrange);  { resolved seg #, def = ref }
                     PRIVREF:
                         (newoffset: lcrange);   { newly assigned base offset }
                     EXTPROC,
                     EXTFUNC,
                     SEPPROC,
                     SEPFUNC:
                         (needsrch: boolean;     { refs haven't been found }
                          newproc: 0..MAXPROC)   { proc #, comp or link chosen }
                   end { workrec } ;             { 0 implies added proc }

   var s: segindex;
       segbase: codep;   { address of current seg being crunched }
       segleng,          { final code seg length for writeout }
       nextblk: integer; { next available output code block }
       uprocs,           { unresolved external proc/func work list }
       procs,            { resolved list of above items }
       ulocal,           { unresolved list of updates for seginfo entry }
       local,            { resolved list of fixups that came along with seg }
       uother,           { unresolved work list of things other than procs }
       other: workp;     { resolved list of above }
       sephost: boolean; { flag for interpreter host case (only seg #1) }
       fname: string[39];{ output code file name }
       segtbl: I5segtbl; { output code's seg table }
       map: text;        { map text output file }

     {
     *  Buildworklists is called for all segments which need to
     *  be copied, and maybe need to have sepprocs or others stuff
     *  fixed up within them.  The idea here is to get a list
     *  of procs and other item needing attention, with
     *  all the subtle implications of global defs falling
     *  in procs which are not yet selected for linking etc.
     *  In fact, three lists are built:
     *     The procs list with all procs and func to be grabbed
     *  from the various sep segs.
     *     The local list of refs in the original segment which must
     *  ALL be fixed up such as public or private refs in a unit seg.
     *     The other list which has work items which have at least one
     *  ref occuring in the procs or funcs in the procs list.
     }

     procedure buildworklists;
       var sp: segp;
           wp: workp;

         {
         *  Findprocs goes through symtab and builds a list of
         *  procedure and functions which occur in the tree and
         *  whose litype is in the okset.  The resulting list
         *  is not ordered in any particular fashion.  It is
         *  called to build initial uproc list.
         }

         function findprocs(okset: liset; symtab: symp): workp;
           var work: workp;

             {
             *  procsrch recursivly searches subtrees to pick out
             *  those symbols which are in the okset, generates
             *  new work nodes, and puts them into local work list.
             }

             procedure procsrch(sym: symp);
               var wp: workp;
             begin
               if sym <> NIL then
                 begin
                   procsrch(sym^.llink);
                   procsrch(sym^.rlink);
                   procsrch(sym^.slink);
                   if sym^.entry.litype in okset then
                     begin { place new node in list }
                       new(wp);
                       wp^.refsym := sym;
                       wp^.refseg := NIL;
                       wp^.defsym := NIL;
                       wp^.defseg := NIL;
                       wp^.needsrch := TRUE;
                       if sephost then
                         wp^.newproc := 0  { see readsrcseg! }
                       else
                         wp^.newproc := sym^.entry.srcproc;
                       wp^.next := work;
                       work := wp
                     end
                 end
             end { procsrch } ;

         begin { findprocs }
           work := NIL;
           procsrch(symtab);
           findprocs := work
         end { findprocs } ;

         {
         *  Findnewprocs is called to place new procedures into the
         *  uprocs work list that are needed to resolve GLOBDEFs,
         *  SEPPREFs, and SEPFREFs.  The other list is traversed and
         *  for each element whose defining proc has not been added
         *  into the uprocs list, the defining proc is located and
         *  added into uprocs.
         }

         procedure findnewprocs;
           var wp, wp1: workp;
               pnum: integer;

             {
             *  Findnadd finds the procedure numbered pnum in the
             *  symbol table symtab.  An error is given if the
             *  required proc cannot be found. It returns a work
             *  node for the proc once it has been found.  This
             *  node is also added into the uprocs list.  Any procs
             *  added this way are "invisible", dragged along because
             *  of global refs/defs.
             }

             function findnadd(symtab: symp): workp;

                 {
                 *  procsrch recursivly searches the sym tree looking
                 *  for the actual symbol containing pnum.  This does
                 *  most of the work of findnadd.
                 }

                 procedure procsrch(sym: symp);
                   var wp: workp;
                 begin
                   if sym <> NIL then
                     begin
                       procsrch(sym^.llink);
                       procsrch(sym^.rlink);
                       procsrch(sym^.slink);
                       if sym^.entry.litype in [SEPPROC, SEPFUNC] then
                         if sym^.entry.srcproc = pnum then
                           begin
                             new(wp);
                             wp^.refsym := sym;
                             wp^.refseg := NIL;
                             wp^.defsym := NIL;
                             wp^.defseg := NIL;
                             wp^.needsrch := TRUE;
                             wp^.newproc := 0;
                             wp^.next := uprocs;
                             uprocs := wp;
                             findnadd := wp;
                             exit(findnadd)
                           end
                     end
                 end { procsrch } ;

             begin { findnadd }
               findnadd := NIL;
               procsrch(symtab);
               { if we get here then didnt find it }
               error('missing proc')
             end { findnadd } ;

         begin { findnewprocs }
           wp := other;      { assume only globref, seppref, sepfref in list }
           while wp <> NIL do
             begin
               if wp^.defproc = NIL then
                 begin { find proc/func needed }
                   if wp^.refsym^.entry.litype = GLOBREF then
                     pnum := wp^.defsym^.entry.homeproc
                   else { assume a SEP proc/func }
                     pnum := wp^.defsym^.entry.srcproc;
                   wp1 := procs;
                   while wp1 <> NIL do
                     if wp^.defseg = wp1^.defseg then
                       if wp1^.defsym^.entry.srcproc = pnum then
                         begin { already gonna be linked }
                           wp^.defproc := wp1;
                           wp1 := NIL
                         end
                       else
                         wp1 := wp1^.next
                     else
                       wp1 := wp1^.next;
                   if wp^.defproc = NIL then { forcibly link it }
                     wp^.defproc := findnadd(wp^.defseg^.symtab)
                 end;
               wp := wp^.next
             end { while }
         end { findnewprocs } ;

         {
         *  Resolve removes work items from inlist, searches symtabs
         *  for its corresponding definition symbol (error if not found),
         *  and moves the work item into the output list.  Each flavor
         *  of work item needs some special handling to collect extra
         *  info related to specific things.  In general, defsym and
         *  defseg are filled in.  The insert algorithm is special for
         *  procedure types to make life easier on refsrch.
         }

         procedure resolve(var inlist, outlist: workp);
           var seg: segrange;
               err: boolean;
               wp: workp;

             {
             *  Sepsrch sequentially search the symtabs in the seplist
             *  to resolve the refsym of inlist^.  It basically just
             *  calls symsrch repetively and fixes up defsym and
             *  defseg fields.  If the name of the refsym could
             *  not be found, an error is given.
             }

             procedure sepsrch(oktype: litypes);
               var syp: symp;
                   sp: segp;
             begin
               sp := seplist;
               while sp <> NIL do
                 begin
                   syp := symsrch(inlist^.refsym^.entry.name,
                                  oktype, sp^.symtab);
                   if syp <> NIL then
                     begin
                       inlist^.defsym := syp;
                       inlist^.defseg := sp;
                       sp := NIL
                     end
                   else
                     sp := sp^.next
                 end
             end { sepsrch } ;

             {
             *  Procinsert is called to insert work into the procs
             *  list using a special set of sort keys so that copyin-
             *  procs will run reasonably fast and use the disk
             *  efficiently.  The procs list is sorted by segment,
             *  srcbase keys.  The seg ordering is dictated by the
             *  seplist, so user ASECTS etc will retain their original
             *  ordering.
             }

             procedure procinsert(work: workp);
               label 1;
               var crnt, prev: workp;
                   sp: segp;
             begin
               prev := NIL;
               sp := seplist;
               while sp <> outlist^.defseg do
                 if sp = work^.defseg then
                   goto 1
                 else
                   sp := sp^.next;
               crnt := outlist;
               repeat
                 if crnt^.defseg = work^.defseg then
                   repeat
                     if work^.defsym^.entry.place^.srcbase <
                        crnt^.defsym^.entry.place^.srcbase then
                       goto 1;
                     prev := crnt;
                     crnt := crnt^.next;
                     if crnt = NIL then
                       goto 1
                   until crnt^.defseg <> work^.defseg
                 else
                   begin
                     prev := crnt;
                     crnt := crnt^.next;
                     if crnt <> NIL then
                       while sp <> crnt^.defseg do
                         if sp = work^.defseg then
                           goto 1
                         else
                           sp := sp^.next
                   end
               until crnt = NIL;
           1:
               if prev = NIL then
                 begin
                   work^.next := outlist;
                   outlist := work
                 end
               else
                 begin
                   work^.next := prev^.next;
                   prev^.next := work
                 end
             end { procinsert } ;

         begin { resolve }
           while inlist <> NIL do
             begin
               with inlist^, refsym^.entry do
                 case litype of
                   GLOBREF:    begin
                                 sepsrch(GLOBDEF);
                                 defproc := NIL
                               end;

                   CONSTREF:   if hostsp <> NIL then
                                 begin
                                   defsym := symsrch(name, CONSTDEF,
                                                 hostsp^.symtab);
                                   defseg := hostsp
                                 end;

                   PUBLREF:    if hostsp <> NIL then
                                 begin
                                   defsym := symsrch(name, PUBLDEF,
                                                 hostsp^.symtab);
                                   defseg := hostsp
                                 end;

                   PRIVREF:    begin
                                 newoffset := nextbaselc;
                                 nextbaselc := nextbaselc+nwords;
                                 if hostsp <> NIL then
                                   defsym := refsym;
                                 defseg := hostsp
                               end;
                   EXTPROC,
                   SEPPROC,
                   SEPPREF:    begin
                                 sepsrch(SEPPROC);
                                 if litype = SEPPREF then
                                   defproc := NIL;
                                 err := FALSE;
                                 if defsym <> NIL then
                                   if litype = SEPPREF then
                                     err := defsym^.entry.nparams <> nwords
                                   else
                                     err := defsym^.entry.nparams <> nparams;

                                 if err then
                                   begin
                                     write('Proc ', name);
                                     error(' param mismatch')
                                   end
                               end;
                   EXTFUNC,
                   SEPFUNC,
                   SEPFREF:    begin
                                 sepsrch(SEPFUNC);
                                 if litype = SEPFREF then
                                   defproc := NIL;
                                 err := FALSE;
                                 if defsym <> NIL then
                                   if litype = SEPFREF then
                                     err := defsym^.entry.nparams <> nwords
                                   else
                                     err := defsym^.entry.nparams <> nparams;
                                 if err then
                                   begin
                                     write('Func ', name);
                                     error(' param mismatch')
                                   end
                               end;

                   UNITREF:    if unitsrch(hostfile, name, seg) = hostfile then
                                 begin { will be found in host }
                                   defsym := refsym;
                                   defsegnum := seg
                                 end
                               else { "impossible" }
                                 error('unit err')
                 end { cases } ;

               wp := inlist;
               inlist := wp^.next;
               if wp^.defsym = NIL then
                 with wp^.refsym^.entry do
                   begin
                     case litype of
                       GLOBREF:  write('Global ');
                       PUBLREF:  write('Public ');
                       CONSTREF: write('Const ');
                       SEPPREF,
                       EXTPROC:  write('Proc ');
                       SEPFREF,
                       EXTFUNC:  write('Func ')
                     end { cases } ;
                     write(name);
                     error(' undefined')
                   end
               else
                 if  (wp^.defsym^.entry.litype in [SEPPROC, SEPFUNC])
                 and (outlist <> NIL) then
                   procinsert(wp)
                 else
                   begin
                     wp^.next := outlist;
                     outlist := wp
                   end
             end { while }
         end { resolve } ;

         {
         *  Refsrch slowly goes through all reference lists in symbols
         *  which are in the okset to see if any "occur" within the
         *  procedures/functions selected to be linked, that is contained
         *  in procs list.  It is assumed that procs is sorted by defseg
         *  so only the procs between ipl and lpl are searched.
         *  Any symbols which have any refs in selected procs are given
         *  work nodes and are placed in the uother list in no certain
         *  order so resolve can be called right away.
         }

         procedure refsrch(okset: liset; sp: segp);
           var lpl, ipl: workp;
               diffseg: boolean;

             {
             *  Checkrefs recursivly searches sym tree to kind names
             *  in the okset.  When one is found, each of its ref pointers
             *  are checked to see if they fall in one of the procs
             *  to-be-linked (between ipl & lpl).  If so, a new work item
             *  is generated and it's put on the uother list.
             }

             procedure checkrefs(sym: symp);
               label 1, 2;
               var pl, wp: workp;
                   i, n, ref: integer;
                   rp: refp;
             begin
               if sym <> NIL then
                 begin
                   checkrefs(sym^.llink);
                   checkrefs(sym^.rlink);
                   checkrefs(sym^.slink);
                   with sym^.entry do
                     if litype in okset then
                       begin
                         n := nrefs;
                         rp := reflist;
                         while rp <> NIL do
                           begin
                             if n > 8 then
                               begin
                                 i := 7;
                                 n := n-8
                               end
                             else
                               i := n-1;
                             repeat { for each ref }
                               ref := rp^.refs[i];
                               pl := ipl;
                               repeat { search proc list }
                                 if pl^.needsrch then
                                   with pl^.defsym^.entry.place^ do
                                     if ref < srcbase then
                                       goto 2 { terminate proc search }
                                     else
                                       if ref < srcbase+length then
                                         begin { occurs in proc }
                                           new(wp);
                                           wp^.refsym := sym;
                                           wp^.refseg := sp;
                                           wp^.defsym := NIL;
                                           wp^.defseg := NIL;
                                           wp^.next := uother;
                                           uother := wp;
                                           goto 1
                                         end;
                                 pl := pl^.next
                               until pl = lpl;
                           2:
                               i := i-1
                             until i < 0;
                             rp := rp^.next
                           end { while }
                       end
                 end;
           1:
             end { checkrefs } ;

         begin { refsrch }
           ipl := NIL;
           lpl := procs;
           while lpl <> NIL do
             if (lpl^.defseg = sp)
             and lpl^.needsrch then
               begin
                 ipl := lpl;
                 lpl := NIL
               end
             else
               lpl := lpl^.next;
           if ipl <> NIL then
             begin
               lpl := ipl;
               repeat
                 diffseg := lpl^.defseg <> ipl^.defseg;
                 if not diffseg then
                   lpl := lpl^.next
               until diffseg or (lpl = NIL);
               checkrefs(sp^.symtab);
               repeat
                 ipl^.needsrch := FALSE;
                 ipl := ipl^.next
               until ipl = lpl
             end
         end { refsrch } ;

         {
         *  findlocals recursivly searches the main segs symtab to
         *  place any unresolved things like public refs in unit
         *  segs into the ulocal list so they can be fixed up in
         *  fixuprefs in addition to the sep proc things.
         }

         procedure findlocals(sym: symp);
           var wp: workp;
         begin
           if sym <> NIL then
             begin
               findlocals(sym^.llink);
               findlocals(sym^.rlink);
               findlocals(sym^.slink);
               if sym^.entry.litype in [UNITREF, PUBLREF, PRIVREF] then
                 begin
                   new(wp);
                   wp^.refsym := sym;
                   wp^.refseg := NIL;
                   wp^.defsym := NIL;
                   wp^.defseg := NIL;
                   wp^.next := ulocal;
                   ulocal := wp
                 end
             end
         end { findlocals } ;

     begin { buildworklists }
       procs := NIL;
       local := NIL;
       other := NIL;
       uprocs := NIL;
       ulocal := NIL;
       uother := NIL;
       with seginfo[s]^ do
         if segkind <> LINKED then
           begin
             sephost := segkind = SEPRTSEG;
             if sephost then
               begin
                 next := seplist;
                 seplist := seginfo[s];
                 uprocs := findprocs([SEPPROC, SEPFUNC], symtab)
               end
             else
               uprocs := findprocs([EXTPROC, EXTFUNC], symtab);
             while uprocs <> NIL do
               begin
                 resolve(uprocs, procs);
                 sp := seplist;
                 while sp <> NIL do
                   begin
                     refsrch([GLOBREF, SEPPREF, SEPFREF], sp);
                     sp := sp^.next
                   end;
                 resolve(uother, other);
                 findnewprocs
               end;
             if not sephost then
               begin
                 findlocals(symtab);
                 resolve(ulocal, local)
               end;
             wp := procs;
             while wp <> NIL do
               begin
                 wp^.needsrch := TRUE;
                 wp := wp^.next
               end;
             sp := seplist;
             while sp <> NIL do
               begin
                 refsrch([PUBLREF, PRIVREF, CONSTREF], sp);
                 sp := sp^.next
               end;
             resolve(uother, other)
           end
     end { buildworklists } ;

 { $I link3b }

     (******************************************************************)
     (*                                                                *)
     (*  Copyright (c) 1978 Regents of the University of California.   *)
     (*  Permission to copy or distribute this software or documen-    *)
     (*  tation in hard or soft copy granted only by written license   *)
     (*  obtained from the Institute for Information Systems.          *)
     (*                                                                *)
     (******************************************************************)

     {
     *  Readsrcseg determines the final segment size after adding
     *  in the external procs/funcs, allocates enough area for the
     *  entire output code seg, reads in the original code (or uses
     *  identity segment for sephost special case), and splits the
     *  segdict off from the code.  For all procs to-be-linked, a new
     *  destbase position is assigned in seg and the new proc num is
     *  set up in pdict.  The segment number field of the pdict is
     *  also updated to the value of s.  All is ready to copy in the
     *  sep procs/funcs.  The values for segbase and segleng are set
     *  here too.
     }

     procedure readsrcseg;
       var orgleng, addr,
           addleng, addprocs,
           nextspot: integer;
           last: 0..MAXPROC;
           wp: workp;
           lheap: ^integer;

         {
         *  Readnsplit arranges for the source seg to be placed in
         *  room allocated for segbase.  This may involve disk read
         *  or perhaps only creating an empty segment.  In any case
         *  segbase points at lowest addr, and nextspot is pointed
         *  at the next place code can be copied into.  This is used
         *  for destbase assignment in readsrcseg.
         }

         procedure readnsplit;
           var nblocks, n, pdleng,
               pddelta, nprocs: integer;
               cp0, cp1: codep;
         begin
           nblocks := (segleng+511) div 512;
           if memavail-400 < nblocks*256 then
             begin
               error('no mem room');
               exit(linker)
             end;
           n := nblocks;
           repeat
             { alloc heap space }
             new(cp1);
             n := n-1
           until n <= 0;
           if sephost then
             begin { set up identity seg }
               storeword(0, segbase, segleng-2);
               nextspot := 0
             end
           else
             begin { read from disk }
               nblocks := (orgleng+511) div 512;
               if blockread(seginfo[s]^.srcfile^.code^, segbase^,
                         nblocks, addr) <> nblocks then
                 begin
                   error('seg read err');
                   exit(linker)
                 end;
               pddelta := segleng-orgleng;
               nprocs := fetchbyte(segbase, orgleng-1);
               pdleng := nprocs*2+2;
               nextspot := orgleng-pdleng;
               cp0 := getcodep(ord(segbase)+orgleng-pdleng);
               cp1 := getcodep(ord(segbase)+segleng-pdleng);
               if cp0 <> cp1 then
                 begin { move proc dict }
                   n := pdleng;
                   while n > 2 do
                     begin
                       storeword(pddelta+fetchword(segbase, orgleng-n),
                           segbase, orgleng-n);
                       n := n-2
                     end;
                   moveright(cp0^, cp1^, pdleng);
                   fillchar(cp0^, pddelta, 0)
                 end
             end
         end { readnsplit } ;

     begin { readsrcseg }
       if sephost then
         orgleng := 2
       else
         with seginfo[s]^, srcfile^.segtbl.diskinfo[srcseg] do
           begin
             orgleng := codeleng;
             addr := codeaddr
           end;
       addleng := 0;
       addprocs := 0;
       wp := procs;
       while wp <> NIL do
         begin { add up final seg size }
           addleng := addleng+wp^.defsym^.entry.place^.length;
           if wp^.newproc = 0 then
             addprocs := addprocs+1;
           wp := wp^.next
         end;
       mark(lheap);
       segbase := getcodep(ord(lheap));
       segleng := orgleng+addleng+2*addprocs;
       if segleng <= 0 then
         begin
           error('size oflow');
           exit(linker)
         end;
       readnsplit;
       last := fetchbyte(segbase, segleng-1);
       wp := procs;
       while wp <> NIL do
         begin { assign places in code seg }
           with wp^.defsym^.entry.place^ do
             begin
               destbase := nextspot;
               nextspot := nextspot+length
             end;
           if wp^.newproc = 0 then
             begin { assign new proc # }
               last := last+1;
               if last > MAXPROC then
                 begin
                   error('proc num oflow');
                   last := 1
                 end;
               wp^.newproc := last
             end;
           wp := wp^.next
         end;
       storebyte(last, segbase, segleng-1);
       storebyte(s, segbase, segleng-2)
     end { readsrcseg } ;

     {
     *  Copyinprocs goes through procs list and copies procedure
     *  bodies from the sep segs into the dest code segment into
     *  locations set up in readsrcseg. If all goes right, we should
     *  fill dest seg to the exact byte.  The proc dict is
     *  updated to show procedures' position.
     }

     procedure copyinprocs;
       var cp0, cp1, pdp,
           jtab, sepbase: codep;
           wp: workp;
           cursp: segp;
           lheap: ^integer;

         {
         *  Readsepseg reads the sep seg in sp onto the heap as
         *  done in Phase 2.  We set up sepbase and cursp for
         *  copyinprocs.
         }

         procedure readsepseg(sp: segp);
           var n, nblocks: integer;
         begin
           release(lheap);
           n := sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeleng;
           nblocks := (n+511) div 512;
           if memavail-400 < nblocks*256 then
             begin
               error('out of mem');
               exit(linker)
             end;
           n := nblocks;
           repeat
             new(sepbase);
             n := n-1
           until n <= 0;
           sepbase := getcodep(ord(lheap));
           if blockread(sp^.srcfile^.code^, sepbase^, nblocks,
               sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeaddr) <> nblocks then
             begin
               error('sep seg read err');
               exit(linker)
             end;
           cursp := sp
         end { readsepseg } ;

     begin { copyinprocs }
       sepbase := NIL;
       cursp := NIL;
       mark(lheap);
       wp := procs;
       while wp <> NIL do
         with wp^, defsym^.entry do
           begin { copy in each proc }
             if cursp <> defseg then
               readsepseg(defseg);
             if talkative then
               begin
                 write('   Copying ');
                 if litype = SEPPROC then
                   write('proc ')
                 else
                   write('func ');
                 writeln(name)
               end;
             cp0 := getcodep(ord(sepbase)+place^.srcbase);
             cp1 := getcodep(ord(segbase)+place^.destbase);
             moveleft(cp0^, cp1^, place^.length);
             jtab := getcodep(ord(segbase)+place^.destbase+place^.length-2);
             if fetchbyte(jtab, 0) <> 0 then
               storebyte(newproc, jtab, 0);
             pdp := getcodep(ord(segbase)+segleng-2*newproc-2);
             storeword(ord(pdp)-ord(jtab), pdp, 0);
             wp := next
           end;
       release(lheap)
     end { copyinprocs } ;

     {
     *  Fixuprefs is called to search through reflists and fix
     *  operand fields of P-code and native code to refer to the
     *  resolved values.  If fixallrefs is true, then all pointers
     *  in the ref lists are used, otherwise the reference pointers
     *  are checked to see if they occur in the procs to-be-linked.
     }

     procedure fixuprefs(work: workp; fixallrefs: boolean);
       var n, i, ref, val: integer;
           wp, wp1: workp;
           rp: refp;
           skipit: boolean;
           r: packed record
                case boolean of
                  TRUE:  (integ: integer);
                  FALSE: (lowbyte: 0..255;
                          highbyte: 0..255)
              end { r } ;
     begin
       while work <> NIL do
         with work^, refsym^.entry do
           begin { for each work item }
                 { figure resolve val }
             case litype of
               SEPPREF,
               SEPFREF:  val := defproc^.newproc;
               UNITREF:  val := defsegnum;
               CONSTREF: val := defsym^.entry.constval;
               GLOBREF:  val := defsym^.entry.icoffset+
                                defproc^.defsym^.entry.place^.destbase;
               PUBLREF,
               PRIVREF:  begin
                           if litype = PRIVREF then
                             val := newoffset
                           else
                             val := defsym^.entry.baseoffset;
                           if format = WORD then
                             val := (val-1)*2+MSDELTA
                           else { assume BIG }
                             if val >= 0 then
                               begin
                                 r.highbyte := val mod 256;
                                 r.lowbyte := val div 256 + 128;
                                 val := r.integ
                               end
                             else
                               error('addr oflow')
                         end
             end;
             n := nrefs;
             rp := reflist;
             while rp <> NIL do
               begin
                 if n > 8 then
                   begin
                     i := 7;
                     n := n-8
                   end
                 else
                   i := n-1;
                 repeat
                   ref := rp^.refs[i];
                   skipit := not fixallrefs;
                   if skipit then
                     begin { see if pertinent }
                       wp := NIL;
                       wp1 := procs;
                       while wp1 <> NIL do
                         if wp1^.defseg = refseg then
                           begin { find matching seg }
                             wp := wp1;
                             wp1 := NIL
                           end
                         else
                           wp1 := wp1^.next;
                       while (wp <> NIL) and skipit do
                         if wp^.defseg = refseg then
                           with wp^.defsym^.entry.place^ do
                             if ref >= srcbase then
                               if ref < srcbase+length then
                                 begin
                                   ref := ref-srcbase+destbase;
                                   skipit := FALSE
                                 end
                               else
                                 wp := wp^.next
                             else
                               wp := NIL
                         else
                           wp := NIL
                     end;
                   if not skipit then
                     case format of { fix up this ref }
                       WORD:  storeword(val+fetchword(segbase, ref),
                                                 segbase, ref);
                       BYTE:  storebyte(val, segbase, ref);
                       BIG:   storeword(val, segbase, ref)
                     end;
                   i := i-1
                 until i < 0;
                 rp := rp^.next
               end;
             work := next
           end
     end { fixuprefs } ;

     {
     *  writetocode takes the finalized destseg and puts it in
     *  the output code file.  This also involves setting up values
     *  in the final segtable for writeout just before locking it.
     }

     procedure writetocode;
       var nblocks: integer;
           jtab: codep;
     begin
       if hostsp = seginfo[s] then
         begin { fix up baselc }
           jtab := getcodep(ord(segbase)+segleng-4);
           jtab := getcodep(ord(jtab)-fetchword(jtab, 0));
           storeword(nextbaselc*2-6, jtab, -8)
         end;
       with seginfo[s]^, segtbl do
         begin
           nblocks := (segleng+511) div 512;
           if blockwrite(code, segbase^, nblocks, nextblk) <> nblocks then
             begin
               error('code write err');
               exit(linker)
             end;
           diskinfo[s].codeaddr := nextblk;
           diskinfo[s].codeleng := segleng;
           segname[s] := srcfile^.segtbl.segname[srcseg];
           segkind[s] := LINKED;
           nextblk := nextblk+nblocks
         end
     end { writetocode } ;

     {
     *  Linksegment is called for each segment to be placed into
     *  the final code file.  The global var s has the seginfo index
     *  pertaining to the segment, and all the other procedures of
     *  Phase 3 are called from here.  This proc facilitates linking
     *  the master seg separatly from the other segs to ensure that
     *  the DATASZ of the outer block correctly reflects the number
     *  of PRIVREF words allocated by resolve.
     }

     procedure linksegment;

         {
         *  Writemap is called for each seg to write some
         *  info into map file.
         }

         procedure writemap;
           var wp: workp;
               b: boolean;
         begin
           with seginfo[s]^ do
             writeln(map, 'Seg # ',s,', ', srcfile^.segtbl.segname[srcseg]);
           wp := procs;
           if wp <> NIL then
             writeln(map, '   Sep procs');
           while wp <> NIL do
             with wp^.defsym^.entry do
               begin
                 write(map, '      ', name);
                 if litype = SEPPROC then
                   write(map, ' proc')
                 else
                   write(map, ' func');
                 write(map, ' # ', wp^.newproc: 3);
                 write(map, '    base =', place^.destbase: 6);
                 write(map, '    leng =', place^.length: 5);
                 writeln(map);
                 wp := wp^.next
               end;
           for b := FALSE to TRUE do
             begin
               if b then
                 begin
                   wp := other;
                   if wp <> NIL then
                     writeln(map, '   Sep proc refs')
                 end
               else
                 begin
                   wp := local;
                   if wp <> NIL then
                     writeln(map, '   Local seg refs')
                 end;
               while wp <> NIL do
                 with wp^.defsym^.entry do
                   begin
                     write(map, '      ', name);
                     case litype of
                       SEPPROC,
                       SEPFUNC:   ;
                       PUBLDEF:   write(map, ' public LC =', baseoffset: 5);
                       CONSTDEF:  write(map, ' const val =', constval: 6);
                       PRIVREF:   write(map, ' privat LC =', wp^.newoffset: 5);
                       UNITREF:   write(map, ' unit seg# =', wp^.defsegnum: 3);
                       GLOBDEF:   write(map, ' glob def in ',
                                     wp^.defproc^.defsym^.entry.name,
                                     ' @', icoffset: 5)
                     end;
                     writeln(map);
                     wp := wp^.next
                   end
             end;
           writeln(map)
         end { writemap } ;

     begin { linksegment }
       sephost := FALSE;
       segbase := NIL;
       segleng := 0;
       if talkative then
         with seginfo[s]^ do
           writeln('Linking ',
                    srcfile^.segtbl.segname[srcseg], ' # ', s);
       buildworklists;
       if errcount = 0 then
         begin
           readsrcseg;
           if mapname <> '' then
             writemap;
           copyinprocs;
           fixuprefs(local, TRUE);
           fixuprefs(other, FALSE);
           writetocode
         end;
       if sephost then
         seplist := seginfo[s]^.next;
       release(heapbase)
     end { linksegment } ;

 begin { phase3 }
   if not useworkfile then
     begin
       write('Output file? ');
       readln(fname);
       useworkfile := fname = ''
     end;
   if useworkfile then
     rewrite(code, '*SYSTEM.WRK.CODE[*]')
   else
     rewrite(code, fname);
   if IORESULT <> 0 then
     begin
       error('Code open err');
       exit(linker)
     end;
   nextblk := 1;
   { clear output seg table }
   fillchar(segtbl, sizeof(segtbl), 0);
   with segtbl do
     for s := 0 to MAXSEG do
       begin
         segname[s] := '        ';
         segkind[s] := LINKED
       end;
   if mapname <> '' then
     begin
       rewrite(map, mapname);
       if IORESULT <> 0 then
         begin
           writeln('Can''t open ', mapname);
           mapname := ''
         end
       else
         begin
           write(map, 'Link map for ');
           if hostsp <> NIL then
             writeln(map, hostsp^.srcfile^.segtbl.segname[hostsp^.srcseg])
           else
             writeln(map, 'assem host');
           writeln(map)
         end
     end;
   mark(heapbase);
   unitwrite(3, heapbase^, 35);
   { link all but host }
   for s := 0 to MAXSEG do
     if (seginfo[s] <> NIL)
     and (seginfo[s] <> hostsp) then
       linksegment;
   { link host last! }
   if hostsp <> NIL then
     begin
       s := MASTERSEG;
       linksegment
     end;
   if blockwrite(code, segtbl, 1, 0) <> 1 then
     error('Code write err');
   if errcount = 0 then
     begin { final cleanup }
       close(code, LOCK);
       if useworkfile then
         with userinfo do
           begin
             gotcode := TRUE;
             codevid := syvid;
             codetid := 'SYSTEM.WRK.CODE'
           end;
       if mapname <> '' then
         begin
           if hostsp <> NIL then
             writeln(map, 'next base LC = ', nextbaselc);
           close(map, LOCK)
         end
     end

 end { phase3 } ;


 begin { linker }
   phase1;
   phase2;
   phase3;
   unitclear(3)
 end { linker } ;

 begin end.

{ +------------------------------------------------------------------+
  |                                                                  |
		|                     F     I     N     I     S                    |
		|                                                                  |
		+------------------------------------------------------------------+ }
